home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / mops / tiny-rpp.txt < prev    next >
Text File  |  1993-07-23  |  15KB  |  524 lines
  1. ; Mode: Scheme
  2. ;
  3. ;
  4. ; **********************************************************************
  5. ; Copyright (c) 1992 Xerox Corporation.  
  6. ; All Rights Reserved.  
  7. ;
  8. ; Use, reproduction, and preparation of derivative works are permitted.
  9. ; Any copy of this software or of any derivative work must include the
  10. ; above copyright notice of Xerox Corporation, this paragraph and the
  11. ; one after it.  Any distribution of this software or derivative works
  12. ; must comply with all applicable United States export control laws.
  13. ;
  14. ; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS
  15. ; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE
  16. ; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
  17. ; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY
  18. ; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS
  19. ; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING
  20. ; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED
  21. ; OF THE POSSIBILITY OF SUCH DAMAGES.
  22. ; **********************************************************************
  23. ;
  24. ; EDIT HISTORY:
  25. ;
  26. ;      10/**/92  Gregor  Originally Written
  27. ; 1.0  11/10/92  Gregor  Changed names of generic invocation generics.
  28. ;                        Changed compute-getters-and-setters protocol.
  29. ;                        Made comments match the code.
  30. ;                        Changed maximum line width to 72.
  31. ; 1.1  11/24/92  Gregor  Heavily edited to produce the reflective
  32. ; RPP                    processor program that is actually running.
  33. ;                        This is intended to be a tool for discussing
  34. ;                        what the language and protocol should be.
  35. ;                        In the process of doing this, several small
  36. ;                        bugs were discovered, see the tiny-clos.scm
  37. ;                        file.
  38. ; 1.2  12/02/92  Gregor  See tiny-clos.scm.
  39. ; 1.3  12/08/92  Gregor  See tiny-clos.scm.
  40. ;
  41. ;       
  42. (define tiny-clos-version "1.3.RPP")
  43.  
  44. ;
  45. ; A very simple CLOS-like language, embedded in Scheme, with a simple
  46. ; MOP.  The features of the default base language are:
  47. ;
  48. ;   * Classes, with instance slots, but no slot options.
  49. ;   * Multiple-inheritance.
  50. ;   * Generic functions with multi-methods and class specializers only.
  51. ;   * Primary methods and call-next-method; no other method combination.
  52. ;   * Uses Scheme's lexical scoping facilities as the class and generic
  53. ;     function naming mechanism.  Another way of saying this is that
  54. ;     class, generic function and methods are first-class (meta)objects.
  55. ;
  56. ; While the MOP is simple, it is essentially equal in power to both MOPs
  57. ; in AMOP.  This implementation is not at all optimized, but the MOP is
  58. ; designed so that it can be optimized.  In fact, this MOP allows better
  59. ; optimization of slot access extenstions than those in AMOP.
  60. ; 
  61. ;
  62. ;
  63. ; In addition to calling a generic, the entry points to the default base
  64. ; language are:
  65. ;
  66. ;   (MAKE-CLASS list-of-superclasses list-of-slot-names)
  67. ;   (MAKE-GENERIC)
  68. ;   (MAKE-METHOD list-of-specializers procedure)
  69. ;   (ADD-METHOD generic method)
  70. ;
  71. ;   (MAKE class . initargs)
  72. ;   (INITIALIZE instance initargs)            ;Add methods to this,
  73. ;                                             ;don't call it directly.
  74. ;   
  75. ;   (SLOT-REF  object slot-name)
  76. ;   (SLOT-SET! object slot-name new-value)
  77. ;
  78. ;
  79. ; So, for example, one might do:
  80. ;
  81. ;   (define <position> (make-class (list <object>) (list 'x 'y)))
  82. ;   (add-method initialize
  83. ;       (make-method (list <position>)
  84. ;         (lambda (call-next-method pos initargs)
  85. ;           (for-each (lambda (initarg-name slot-name)
  86. ;                       (slot-set! pos
  87. ;                                  slot-name
  88. ;                                  (getl initargs initarg-name 0)))
  89. ;                     '(x y)
  90. ;                     '(x y)))))
  91. ;
  92. ;   (set! p1 (make <position> 'x 1 'y 3))
  93. ;
  94. ;
  95. ;
  96. ; NOTE!  Do not use EQUAL? to compare objects!  Use EQ? or some hand
  97. ;        written procedure.  Objects have a pointer to their class,
  98. ;        and classes are circular structures, and ...
  99. ;
  100. ;
  101. ;
  102. ; The introspective part of the MOP looks like the following.  Note that
  103. ; these are ordinary procedures, not generics.
  104. ;
  105. ;   CLASS-DIRECT-SUPERS
  106. ;   CLASS-DIRECT-SLOTS
  107. ;   CLASS-CPL
  108. ;   CLASS-SLOTS
  109. ;
  110. ;   GENERIC-METHODS
  111. ;
  112. ;   METHOD-SPECIALIZERS
  113. ;   METHOD-PROCEDURE
  114. ;
  115. ;
  116. ; The intercessory protocol looks like (generics in uppercase):
  117. ;
  118. ;   make                        
  119. ;     ALLOCATE-INSTANCE
  120. ;     INITIALIZE                   (really a base-level generic)
  121. ;
  122. ;   class initialization
  123. ;     COMPUTE-CPL
  124. ;     COMPUTE-SLOTS
  125. ;     COMPUTE-GETTER-AND-SETTER
  126. ;
  127. ;   add-method                     (Notice this is not a generic!)
  128. ;     COMPUTE-APPLY-GENERIC
  129. ;       COMPUTE-METHODS
  130. ;         COMPUTE-METHOD-MORE-SPECIFIC?
  131. ;       COMPUTE-APPLY-METHODS
  132. ;
  133.  
  134. ;
  135. ; As for the low-level memory system, assume the existence of:
  136. ;
  137. ;  %allocate-instance (nfields)
  138. ;  %instance-ref      (instance field-number)
  139. ;  %instance-set!     (instance field-number new)
  140. ;  
  141. ;  %allocate-entity   (nfields)
  142. ;  %entity-ref        (instance field-number)
  143. ;  %entity-set!       (instance field-number new)
  144. ;
  145. ;  class-of           (any-object)
  146. ;
  147.  
  148.  
  149. (define <top>          (make <class>
  150.                  'direct-supers (list)
  151.                  'direct-slots  (list)))
  152.  
  153. (define <object>       (make <class>
  154.                  'direct-supers (list <top>)
  155.                  'direct-slots  (list)))
  156.  
  157. (define <class>
  158.     (make <class>
  159.       'direct-supers (list <object>)
  160.       'direct-slots  
  161.          (list 'direct-supers           ;(class ...)
  162.            'direct-slots            ;((name . options) ...)
  163.            'cpl                     ;(class ...)
  164.            'slots                   ;((name . options) ...)
  165.            'nfields                 ;an integer
  166.            'field-initializers      ;(proc ...)
  167.            'getters-n-setters)))    ;((slot-name getter setter) ...)
  168.  
  169. (define <primitive-class>
  170.     (make <class>
  171.       'direct-supers (list <class>)
  172.       'direct-slots  (list)))
  173.  
  174. (define make-primitive-class
  175.     (lambda class
  176.       (make (if (null? class) <primitive-class> (car class))
  177.         'direct-supers (list <top>)
  178.         'direct-slots  (list))))
  179.  
  180. (define <boolean>   (make-primitive-class))
  181. (define <symbol>    (make-primitive-class))
  182. (define <char>      (make-primitive-class))
  183. (define <vector>    (make-primitive-class))
  184. (define <pair>      (make-primitive-class))
  185. (define <number>    (make-primitive-class))
  186. (define <string>    (make-primitive-class))
  187. (define <procedure> (make-primitive-class <procedure-class>))
  188.  
  189.  
  190. (define <procedure-class> (make <class>
  191.                 'direct-supers (list <class>)
  192.                 'direct-slots  (list)))
  193.  
  194. (define <entity-class>    (make <class>
  195.                     'direct-supers (list <procedure-class>)
  196.                     'direct-slots  (list)))
  197.  
  198. (define <generic>         (make <entity-class>
  199.                     'direct-supers (list <object>)
  200.                     'direct-slots  (list 'methods)))
  201.  
  202. (define <method>          (make <class>
  203.                     'direct-supers (list <object>)
  204.                     'direct-slots  (list 'specializers
  205.                              'procedure)))
  206.  
  207. ;
  208. ; To make the introspective MOP cleaner, we hide the slot names, in the
  209. ; usual CLOS style.  The following are the acccessors which should be
  210. ; used to access information stored in metaobjects.
  211. ;
  212. ;
  213. (define class-direct-slots
  214.     (lambda (class) (slot-ref class 'direct-slots)))
  215. (define class-direct-supers
  216.     (lambda (class) (slot-ref class 'direct-supers)))
  217. (define class-slots
  218.     (lambda (class) (slot-ref class 'slots)))
  219. (define class-cpl
  220.     (lambda (class) (slot-ref class 'cpl)))
  221.  
  222. (define generic-methods
  223.     (lambda (generic) (slot-ref generic 'methods)))
  224.  
  225. (define method-specializers
  226.     (lambda (method) (slot-ref method 'specializers)))
  227. (define method-procedure
  228.     (lambda (method) (slot-ref method 'procedure)))
  229.  
  230.  
  231. ;
  232. ; The initialization protocol
  233. ;
  234. (define initialize (make-generic))
  235.         
  236.  
  237. ;
  238. ; The instance structure protocol.
  239. ;
  240. (define allocate-instance (make-generic))
  241. (define compute-getter-and-setter (make-generic))
  242.  
  243.  
  244. ;
  245. ; The class initialization protocol.
  246. ;
  247. (define compute-cpl (make-generic))
  248. (define compute-slots (make-generic))
  249.  
  250. ;
  251. ; The generic invocation protocol.
  252. ;
  253. (define compute-apply-generic         (make-generic))
  254. (define compute-methods               (make-generic))
  255. (define compute-method-more-specific? (make-generic))
  256. (define compute-apply-methods         (make-generic))
  257.  
  258.  
  259.  
  260. (add-method initialize
  261.     (make-method (list <object>)
  262.       (lambda (call-next-method object initargs) object)))
  263.  
  264. (add-method initialize
  265.     (make-method (list <class>)
  266.       (lambda (call-next-method class initargs)
  267.     (call-next-method)
  268.     (slot-set! class
  269.            'direct-supers
  270.            (getl initargs 'direct-supers '()))
  271.     (slot-set! class
  272.            'direct-slots
  273.            (map (lambda (s)
  274.               (if (pair? s) s (list s)))
  275.             (getl initargs 'direct-slots  '())))
  276.     (slot-set! class 'cpl   (compute-cpl   class))
  277.     (slot-set! class 'slots (compute-slots class))
  278.     (let* ((nfields 0)
  279.            (field-initializers '())
  280.            (allocator
  281.         (lambda (init)
  282.           (let ((f nfields))
  283.             (set! nfields (+ nfields 1))
  284.             (set! field-initializers
  285.               (cons init field-initializers))
  286.             (list (lambda (o)   (get-field  o f))
  287.               (lambda (o n) (set-field! o f n))))))
  288.            (getters-n-setters
  289.         (map (lambda (slot)
  290.                (cons (car slot)
  291.                  (compute-getter-and-setter class
  292.                             slot
  293.                             allocator)))
  294.              (slot-ref class 'slots))))
  295.       (slot-set! class 'nfields nfields)
  296.       (slot-set! class 'field-initializers field-initializers)
  297.       (slot-set! class 'getters-n-setters getters-n-setters)))))
  298.  
  299. (add-method initialize
  300.     (make-method (list <generic>)
  301.       (lambda (call-next-method generic initargs)
  302.     (call-next-method)
  303.     (slot-set! generic 'methods '())
  304.     (%set-entity-proc! generic
  305.                (lambda args (error "Has no methods."))))))
  306.  
  307. (add-method initialize
  308.     (make-method (list <method>)
  309.       (lambda (call-next-method method initargs)
  310.     (call-next-method)
  311.     (slot-set! method 'specializers (getl initargs 'specializers))
  312.     (slot-set! method 'procedure    (getl initargs 'procedure)))))
  313.  
  314.  
  315.  
  316. (add-method allocate-instance
  317.     (make-method (list <class>)
  318.       (lambda (call-next-method class)
  319.     (let* ((field-initializers (slot-ref class 'field-initializers))
  320.            (new (%allocate-instance
  321.               class
  322.               (length field-initializers))))
  323.       (let loop ((n 0)
  324.              (inits field-initializers))
  325.         (if (pair? inits)
  326.         (begin
  327.          (%instance-set! new n ((car inits)))
  328.          (loop (+ n 1)
  329.                (cdr inits)))
  330.         new))))))
  331.  
  332. (add-method allocate-instance
  333.     (make-method (list <entity-class>)
  334.       (lambda (call-next-method class)
  335.     (let* ((field-initializers (slot-ref class 'field-initializers))
  336.            (new (%allocate-entity
  337.               class
  338.               (length field-initializers))))
  339.       (let loop ((n 0)
  340.              (inits field-initializers))
  341.         (if (pair? inits)
  342.         (begin
  343.          (%entity-set! new n ((car inits)))
  344.          (loop (+ n 1)
  345.                (cdr inits)))
  346.         new))))))
  347.  
  348.  
  349.  
  350. (add-method compute-cpl
  351.     (make-method (list <class>)
  352.       (lambda (call-next-method class)
  353.     (compute-std-cpl class class-direct-supers))))
  354.  
  355.  
  356. (add-method compute-slots
  357.     (make-method (list <class>)
  358.       (lambda (call-next-method class)
  359.     (let collect ((to-process (apply append
  360.                      (map class-direct-slots
  361.                           (class-cpl class))))
  362.               (result '()))
  363.       (if (null? to-process)
  364.           (reverse result)
  365.           (let* ((current (car to-process))
  366.              (name (car current))
  367.              (others '())
  368.              (remaining-to-process
  369.               (collect-if (lambda (o)
  370.                     (if (eq? (car o) name)
  371.                     (begin
  372.                      (set! others (cons o others))
  373.                      #f)
  374.                     #t))
  375.                   (cdr to-process))))
  376.         (collect remaining-to-process
  377.              (cons (append current
  378.                        (apply append (map cdr others)))
  379.                    result))))))))
  380.  
  381.  
  382. (add-method compute-getter-and-setter
  383.     (make-method (list <class>)
  384.       (lambda (call-next-method class slot allocator)
  385.     (allocator (lambda () '())))))
  386.  
  387. (define make
  388.     (lambda (class . initargs)
  389.       (let ((instance (allocate-instance class)))
  390.     (initialize instance initargs)
  391.     instance)))
  392.  
  393. (define slot-ref
  394.     (lambda (object slot-name)
  395.       (let* ((info   (lookup-slot-info (class-of object) slot-name))
  396.          (getter (list-ref info 0)))
  397.     (getter object))))
  398.  
  399. (define slot-set!
  400.     (lambda (object slot-name new-value)
  401.       (let* ((info   (lookup-slot-info (class-of object) slot-name))
  402.          (setter (list-ref info 1)))
  403.     (setter object new-value))))
  404.  
  405. (define lookup-slot-info
  406.     (lambda (class slot-name)
  407.       (let* ((getters-n-setters (slot-ref class 'getters-n-setters))
  408.          (entry (assq slot-name getters-n-setters)))
  409.     (if (null? entry)
  410.         (error "No slot" slot-name "in instances of" class)
  411.         (cdr entry)))))
  412.  
  413.  
  414. (define add-method
  415.     (lambda (generic method)
  416.       (slot-set! generic
  417.          'methods
  418.          (cons method
  419.                (filter-in
  420.             (lambda (m)
  421.               (not (every eq?
  422.                       (method-specializers m)
  423.                       (method-specializers method))))
  424.             (slot-ref generic 'methods))))
  425.       (%set-entity-proc! generic (compute-apply-generic generic))))
  426.  
  427.  
  428. (add-method compute-apply-generic
  429.     (make-method (list <generic>)
  430.       (lambda (call-next-method generic)
  431.     (lambda args
  432.       ((compute-apply-methods generic)
  433.        ((compute-methods generic) args)
  434.        args)))))
  435.  
  436. (add-method compute-methods
  437.     (make-method (list <generic>)
  438.       (lambda (call-next-method generic)
  439.     (lambda (args)
  440.       (let ((applicable
  441.          (filter-in (lambda (method)
  442.                   ;
  443.                   ; Note that every only goes as far as the
  444.                   ; shortest list!
  445.                   ;
  446.                   (every applicable?
  447.                      (method-specializers method)
  448.                      args))
  449.                 (generic-methods generic))))
  450.         (gsort (lambda (m1 m2)
  451.              ((compute-method-more-specific? generic)
  452.               m1
  453.               m2
  454.               args))
  455.            applicable))))))
  456.  
  457. (add-method compute-method-more-specific?
  458.     (make-method (list <generic>)
  459.       (lambda (call-next-method generic)
  460.     (lambda (m1 m2 args)
  461.       (let loop ((specls1 (method-specializers m1))
  462.              (specls2 (method-specializers m2))
  463.              (args args))
  464.         (cond ((null? specls1) (return #t))     ;*Maybe these two
  465.           ((null? specls2) (return #f))     ;*should barf?
  466.           ((null? args)
  467.            (error "Fewer arguments than specializers."))
  468.           (else
  469.            (let ((c1  (car specls1))
  470.              (c2  (car specls2))
  471.              (arg (car args)))
  472.              (if (eq? c1 c2)
  473.              (loop (cdr specls1)
  474.                    (cdr specls2)
  475.                    (cdr args))
  476.              (more-specific? c1 c2 arg))))))))))
  477.  
  478. (define applicable?
  479.     (lambda (c arg)
  480.       (memq c (class-cpl (class-of arg)))))
  481.  
  482. (define more-specific?
  483.     (lambda (c1 c2 arg)
  484.       (memq c2 (memq c1 (class-cpl (class-of arg))))))
  485.  
  486. (add-method compute-apply-methods
  487.     (make-method (list <generic>)
  488.       (lambda (call-next-method generic)
  489.     (lambda (methods args)
  490.       (letrec ((one-step
  491.              (lambda (tail)
  492.                (lambda ()
  493.              (if (null? tail)
  494.                  (error "No applicable methods/next methods.")
  495.                  (apply (method-procedure (car tail))
  496.                     (cons (one-step (cdr tail)) args)))))))
  497.         ((one-step methods)))))))
  498.  
  499.  
  500.  
  501.  
  502. ;
  503. ; So that the normal base-level user can live life without knowing there
  504. ; is a MOP, we supply the following convenient syntax.
  505. ;
  506. ;
  507. (define make-class
  508.     (lambda (direct-supers direct-slots)
  509.       (make <class>
  510.         'direct-supers direct-supers
  511.         'direct-slots  direct-slots)))
  512.  
  513. (define make-generic
  514.     (lambda ()
  515.       (make <generic>)))
  516.  
  517. (define make-method
  518.     (lambda (specializers procedure)
  519.       (make <method>
  520.         'specializers specializers
  521.         'procedure    procedure)))
  522.  
  523.  
  524.